data <- read_csv("Mental_Health_copy.csv",
col_types = cols(`Quartile Range` = col_skip(),
`Suppression Flag` = col_skip(),
# LowCI = col_skip(),
# HighCI= col_skip(),
`Confidence Interval`= col_skip()
)) %>%
mutate(t = ifelse(`Time Period`>21, `Time Period`+1,`Time Period`)) %>%
mutate(t2 = ifelse(t==1, 22,t),
CIint = HighCI-LowCI) %>%
select(-c(t,`Time Period`)) %>% rename(`Time Period`=t2)# taking prescription filter
data_states_13_meds <- data %>%
filter(Indicator == "Took Prescription Medication for Mental Health, Last 4 Weeks",
Group == "By State" ) %>%
mutate(State1 = tolower(State)) %>%
select(Value, CIint, State = State1, Indicator, t = `Time Period`, `Time Period Label`) Resources for Value-Suppressing Uncertainty Palettes: https://github.com/clauswilke/multiscales
MainStates <- map_data("state") %>% mutate(State = tolower(region))
merged_pres <- inner_join(MainStates, data_states_13_meds, by = "State")
region.lab.data <- merged_pres %>%
group_by(State) %>% summarise(long=mean(long), lat=mean(lat))
# Color for Value-Suppressing Uncertainty Palettes
colors <- scales::colour_ramp(
colors = c(red = "#AC202F", purple = "#740280", blue = "#2265A3")
)((0:7)/7)
#---- VSUP ggplot
# map_took_pres <- ggplot(merged_pres) +
# geom_polygon(aes(x=long, y=lat, group=group, fill = zip(Value, CIint), frame = t),
# color="white", size = 0.2) +
# bivariate_scale("fill",
# pal_vsup(values = colors, max_desat = 0.8, pow_desat = 0.2, max_light = 0.7, pow_light = 1),
# name = c("Percentage", "uncertainty"),
# # limits = list(c(min(merged_pres$Value), max(merged_pres$Value)),
# # c(min(merged_pres$CIint), max(merged_pres$CIint))),
# breaks = list(waiver(), c(0, 1)),
# # breaks = list(c(10, 15, 20, 25, 30, 35), c(0, 5, 10, 15, 20)),
# labels = list(waiver(), scales::percent),
# guide = "colourfan") + theme_void()
map_took_pres <- ggplot() +
geom_polygon(data=merged_pres,
aes(x=long, y=lat, group=group, fill = Value, frame = t),
color="white", size = 0.2) +
scale_fill_gradient(
low = "lightblue", high = "darkred",
name = c("Percentage")) +
geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
theme_classic()+
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank())+
labs(title="Took Prescription Medication for Mental Health, Last 4 Weeks", fill = "%")
fig <- ggplotly(map_took_pres)
fig <- fig %>%
animation_opts(
50, easing = "elastic", redraw = FALSE
) %>%
animation_slider(
currentvalue = list(prefix = "Time Period ", font = list(color="red"))
) #%>%
# layout(annotations = list(x = -120, y = 25, text = paste("Time Period: ",
# merged_pres$`Time Period Label`), showarrow = F))
fig$x$frames <- lapply(
fig$x$frames, function(f) {
f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
f
})
figdata_states_13_thrp <- data %>%
filter(Indicator == "Received Counseling or Therapy, Last 4 Weeks",
Group == "By State") %>%
mutate(State1 = tolower(State)) %>%
select(Value, State = State1, Indicator, t = `Time Period`, `Time Period Label`)
# merge with state
merged_thrp <- inner_join(MainStates, data_states_13_thrp, by = "State")
map_thrp <- ggplot() +
theme_classic()+
geom_polygon(data=merged_thrp,
aes(x=long, y=lat, group=group, fill = Value, frame = t),
color="white", size = 0.2) +
scale_fill_gradient(
low = "lightblue", high = "darkred",
name = c("Percentage")) +
geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank())+
labs(title="Received Counseling or Therapy, Last 4 Weeks", fill = "%")
fig2 <- ggplotly(map_thrp)
fig2 <- fig2 %>%
animation_opts(
50, easing = "elastic", redraw = FALSE
)%>%
animation_slider(
currentvalue = list(prefix = "Time Period ", font = list(color="red"))
)
fig2$x$frames <- lapply(
fig2$x$frames, function(f) {
f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
f
})
fig2data_states_13_both <- data %>%
filter(Indicator == "Took Prescription Medication for Mental Health And/Or Received Counseling or Therapy, Last 4 Weeks",
Group == "By State"
#,`Time Period` == 13
) %>%
mutate(State1 = tolower(State)) %>%
select(Value, State = State1, Indicator, t = `Time Period`, `Time Period Label`)
# merge with state
merged_both <- inner_join(MainStates, data_states_13_both, by = "State")
map_both <- ggplot() +
theme_classic() +
geom_polygon(data=merged_both,
aes(x=long, y=lat, group=group, fill = Value, frame = t),
color="white", size = 0.2) +
scale_fill_gradient(
low = "lightblue", high = "darkred",
name = c("Percentage")) +
geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
labs(title="Took Prescription Medication for Mental Health And/Or Received Counseling or Therapy, Last 4 Weeks", fill = "%")+
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank())
fig3 <- ggplotly(map_both)
fig3 <- fig3 %>%
animation_opts(
50, easing = "elastic", redraw = FALSE
)%>%
animation_slider(
currentvalue = list(prefix = "Time Period ", font = list(color="red"))
)
fig3$x$frames <- lapply(
fig3$x$frames, function(f) {
f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
f
})
fig3data_states_13_need <- data %>%
filter(Indicator == "Needed Counseling or Therapy But Did Not Get It, Last 4 Weeks",
Group == "By State"
#,`Time Period` == 13
) %>%
mutate(State1 = tolower(State)) %>%
select(Value, State = State1, Indicator, t = `Time Period`, `Time Period Label`)
# merge with state
merged_need <- inner_join(MainStates, data_states_13_need, by = "State")
map_need <- ggplot() +
theme_classic() +
geom_polygon(data=merged_need,
aes(x=long, y=lat, group=group, fill = Value, frame = t),
color="white", size = 0.2) +
scale_fill_gradient(
low = "lightblue", high = "darkred",
name = c("Percentage")) +
geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
labs(title="Needed Counseling or Therapy But Did Not Get It, Last 4 Weeks", fill = "%")+
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank())
fig4 <- ggplotly(map_need)
fig4 <- fig4 %>%
animation_opts(
50, easing = "elastic", redraw = FALSE
)%>%
animation_slider(
currentvalue = list(prefix = "Time Period ", font = list(color="red"))
)
fig4$x$frames <- lapply(
fig4$x$frames, function(f) {
f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
f
})
fig4## # A tibble: 16 x 2
## `Time Period Label` `Time Period`
## <chr> <dbl>
## 1 Aug 19 - Aug 31 13
## 2 Sep 2 - Sep 14 14
## 3 Sep 16 - Sep 28 15
## 4 Sep 30 - Oct 12 16
## 5 Oct 14 - Oct 26 17
## 6 Oct 28 - Nov 9 18
## 7 Nov 11 - Nov 23 19
## 8 Nov 25 - Dec 7 20
## 9 Dec 9 - Dec 21 21
## 10 Dec 22 - Jan 5 22
## 11 Jan 6 - Jan 18 23
## 12 Jan 20 - Feb 1 24
## 13 Feb 3 - Feb 15 25
## 14 Feb 17 - Mar 1 26
## 15 Mar 3 - Mar 15 27
## 16 Mar 17 - Mar 29 28
Mar 17 - Mar 29 –> 27 Dec 22 - Jan 5 –> 1 –> between 21 and 22
period numbers mismatch
add national averages
add state label
By indicator, Drop down info: state, gender, race
## Resource https://plotly.com/r/choropleth-maps/
data_state_pres <- data %>%
filter(Indicator == "Took Prescription Medication for Mental Health, Last 4 Weeks")%>%
pivot_wider(names_from = c("Subgroup"), values_from = "Value") %>%
distinct(.keep_all = T)
# data$hover <- with(data, paste(State, '<br>', "Female", Female, "Male", Male, "<br>",
# "Hispanic or Latino", `Hispanic or Latino`, "<br>",
# "White", `Non-Hispanic white, single race`,
# "Asian", `Non-Hispanic Asian, single race`,"<br>",
# "Black", `Non-Hispanic black, single race`, "Other/Multiple Races",
# `Non-Hispanic, other races and multiple races`))
#
# fig <- plot_geo(df, locationmode = 'USA-states')
# fig <- fig %>% add_trace(
# z = ~total.exports, text = ~hover, locations = ~code,
# color = ~total.exports, colors = 'Purples'
# )
# fig <- fig %>% colorbar(title = "Millions USD")
# fig <- fig %>% layout(
# title = '2011 US Agriculture Exports by State<br>(Hover for breakdown)'
# )
#
# fig